home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
PGM_TOOL
/
PREVIEW
/
CLP2DLFI
/
WPREVIEW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-11-12
|
55KB
|
1,848 lines
Unit wPreview;
interface
uses
Forms, SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Dialogs, ExtCtrls, ShellApi, BTprint, StdCtrls, Buttons, Menus,
VBXctrl, DBFserver, CommonCode;
const PrnInitFile='PrnInit.txt';
MaxLpTitles=20; { Max jobs printing at one time }
MaxPrns=20; { Max printers }
MaxQTypes=10; { Max Defined Queues }
MaxFonts=10; { Max Defined Fonts }
MaxPageLen=58; { Max lines per page (text style printing) }
MaxPages=30; { Max pages per report (if you want previewing) }
ScrnCanvasX=820; { Image width and height for preview image box }
ScrnCanvasY=940;
ScrnRowHeight=900; { Vertical height of canvas for tight
Vertical spacing }
RefPixPerInchX=300; { Reference printer pixels per inch horizontal }
RefPixPerInchY=300; { Reference printer pixels per inch vertical }
RefAspectYdbl:double=300.0; { Used in cmX() and cmY() }
RefAspectXdbl:double=300.0;
ScrnPixPerInchX=70; { GetDeviceCaps() returns 96, I prefer 70 }
ScrnPixPerInchY=70; { Calc by measuring your screen image and dividing
into your screen densities: 640x480, 800x600 }
ScrollPixels=20; { When viewing section of large BMP's, scroll 1/2" }
{ following are passed to StartDoc() }
For8x11=false; { Report designed for 8.5x11 paper size }
For14x11=true; { Report designed for 14x11 paper size }
Dlm='|'; { Delimiter used by AddCommand(), can be more than
one char if a conflict }
type
PrnInfo=Record
{ It may be available but no selectable in the Printer Select window }
PrName:string[30]; { Printer name as it appears in win.ini }
PrPort:string[40]; { Lpt?, 1..3 }
Queue:string[30]; { Queue name as it appears in Network setup }
CanSelect:boolean; { Will appear in Select Printer window }
PrType:integer; { Printer Type, see PRNINIT.TXT, associates queues }
PrWide:Boolean; { Wide carriage style printer? }
end;
LPMain=class(TObject)
public
LptPrinters:array [1..MaxPrns] of PrnInfo;
PrnCnt,AvailCnt,QueueCnt:integer;
AvailType:array [1..MaxPrns] of integer;
QueueType:array [1..MaxPrns,1..MaxQTypes] of integer;
AvailName,QueueName,QueueTitle:array [1..MaxPrns] of string[40];
AvailWide:array [1..MaxPrns] of boolean;
{ fixed width fonts }
FontList:array [1..MaxFonts] of string[40]; { Over 5 are variable width }
{ CurDest, WantsPreview set in Select Printer window }
CurDest:integer; { Current hardcopy destination }
WantsPreview:boolean; { Wants Report Preview }
LastHardCopy:integer; { Last hardcopy printer selected }
procedure LoadPrinters(FromFile:string);
function CurrentPrinterInfo:string;
procedure GetPrinterType(aPrinterName:string;var pType:integer;
pWideCarriage:boolean);
function GetQueueNum(ForQueue:string):Integer;
end;
TPreview = class(TForm)
Image1: TImage;
Panel1: TPanel;
Label1: TLabel;
Panel2: TPanel;
Label3: TLabel;
BitBtn6: TBitBtn;
BitBtn1: TBitBtn;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Label4: TLabel;
Edit1: TEdit;
PopupMenu1: TPopupMenu;
Close1: TMenuItem;
N1: TMenuItem;
FirstPg1: TMenuItem;
PreviousPg1: TMenuItem;
NextPg1: TMenuItem;
LastPg1: TMenuItem;
N2: TMenuItem;
PrintAll1: TMenuItem;
PrintPg1: TMenuItem;
Image2: TImage;
GoToPg1: TMenuItem;
N3: TMenuItem;
Panel3: TPanel;
Label2: TLabel;
Label5: TLabel;
Label6: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure BitBtn6Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure Close1Click(Sender: TObject);
procedure FirstPg1Click(Sender: TObject);
procedure PreviousPg1Click(Sender: TObject);
procedure NextPg1Click(Sender: TObject);
procedure LastPg1Click(Sender: TObject);
procedure PrintAll1Click(Sender: TObject);
procedure PrintPg1Click(Sender: TObject);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image2MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure GoToPg1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
wCommands:array [1..MaxPages] of tstringlist;
ViewPageTot:integer; { Internal Page Counter For Commands[] }
CurPage:integer; { Current Page Being Displayed }
wCurDest:integer; { Next three items set by Lpr before finishing }
wRpWide:boolean;
wShortTitle:string;
wPageTot:integer;
Zoomable,FitToScreen:boolean;
BigX,BigY:integer;
FirstTimeBig:boolean;
useLandScape:boolean; { Set before calling PlayBackPage }
function PlayBackPage(ToScreen:boolean;PageNum:integer):boolean;
procedure SaveCommands(toFile:string);
procedure SetButtons;
procedure ShowBigImage;
procedure LoadCommands(fromFile:string);
public
procedure ShowBluePrint(aCaption,TinyBMP,FullBMP:string);
procedure PrintBluePrint(FullBMP:string);
procedure PrintCommandFile(aLoadSpec:string);
end;
lpr=class(TObject)
private
Row,Col:Integer; { Current printer row,col for TextStyle }
RpWide,FixedWidth:Boolean; { Report width, true if greater than 80 }
RowHeight,ColWidth,Fixed10Width,Fixed12Width,Fixed8Width:integer;
AdjZeroX,AdjZeroY:double; {Used 0,0 offset, in centimeters}
Preview: TPreview;
aCanvas:TCanvas; { Actual display surface }
NumOfCopies:Integer; { Number of copies }
CurDest:integer; { Current hardcopy destination }
CurFont:integer; { Used in SetGDIFont }
Condensed:boolean; { Use condensed print }
RowColStyle:boolean; { Set type of text, set using SetTextStyle }
FromPreview:boolean; { Used by StartDoc2 and Preview window }
useLandScape:boolean; { Set in StartDoc }
Commands:array [1..MaxPages] of tstringlist;
ViewPageTot:integer; { Used with Commands to track pages }
InsideCommand:boolean; { Stop recursion of AddCommand() }
ScaleXby,ScaleYby:longint;
FromLoadToPrint:boolean; { Load an print a command file }
procedure StartDoc2(ToPreview,Over80Wide:boolean;
aBriefTitle:string); { Only used by Preview window }
{ Prints text to selected canvas: screen or printer }
procedure Wout(xpos,ypos:integer;aStr:string);
{ Use to change font and style to one of FontList[] items }
procedure setGDIfont(NewFont:string); { set by pxText() }
{ The following is used to correct alignment,
base reference printer is 300 dpi,
see RefAspectX and RefAspectY below }
procedure SetScaleXY;
procedure SetScaleXY70;
{ Scale reference pixels to current canvas }
function ScaleX(RefX:integer):integer;
function ScaleY(RefY:integer):integer;
{ Easy way to lay out forms, use centimeters from top and left
edge to position items, then print once on printer it is to be
used on, add the adjustments to list in SetZeroXY() routine to
correct 0,0 position, for pre-printed forms }
procedure SetZeroXY(aPrType:integer);
public
ShortTitle:string[70];
Line,Page,PGlen:integer;
WantsPreview:boolean; { Wants report previewing }
WindowDest:boolean; { Raster ops are going to a Window }
PrePrintedForm:boolean; { After SetDestination }
pr:TPrinter; { Used when printing hardcopy }
{ The following vars used to correct alignment when using the
Windows printing system, adjusted proportionally to reference printer
output }
RefAspectX,RefAspectY,PrnAspectY,PrnAspectX:integer;
CanvasWidth,CanvasHeight:integer;
Running,Abort:boolean;
CancelState:integer;
constructor Create;
procedure StartDoc(Over80Wide:boolean;aBriefTitle:string);
procedure StopDoc;
procedure SetCaption(toStr:string);
procedure SetDestination; { Call before StartDoc() }
procedure ForceToScreen; { These two must be after SetDestination, }
procedure ForceToPrinter; { Before StartDoc, to override default dest. }
function Cancel:integer; { 0-not running, 1-continue, 2-abort }
{ Key print commands should start with AddCommand
and end with EndCommand to keep recursion from occuring }
procedure AddCommand(CommandStr:string);
procedure EndCommand;
procedure SetTextStyle(forText:boolean);
{ the following are used to emulate a line printer }
procedure TextFont(NewFont:string); { chng font for line printer style }
procedure Write(astr:string);
procedure WriteLn(astr:string);
procedure P(atrow,atcol:integer;astr:string);
procedure SetRowCol(toRow,toCol:integer);
function pRow:integer;
function pCol:integer;
procedure CrLf;
procedure Eject; { used for both Text and Raster styles }
{ converts designated chars to alternate types, for engineering }
function SpecChars(istr:string):string;
{ the following are used for X,Y canvas-style printing, params are
in Centimeters, easy way to position items, translates Centimeters
to Reference pixels, then passes to px???? commands }
procedure cmLine(left,top,width,height:double);
procedure cmBox(left,top,width,height:double;graylev:integer);
procedure cmText(left,top:double;uzfont,thetext:string);
procedure cmImage(IsColor:boolean;left,top:double;
ScrnBMP,PrintBMP:string);
procedure cmBarCode(left,top,width,height:double;Text:string);
{ actual routines used for X,Y raster printing, params are
in current reference Pixels and use ScaleX and ScaleY to
convert to current canvas pixels, usually called by cm??? }
{ aRect values are: left, top, width, height }
procedure pxLine(aRect:Trect);
procedure pxText(aPoint:TPoint;uzFont,TheText:string);
procedure pxImage(IsColor:boolean;aRect:Trect;ScrnBMP,PrintBMP:string);
procedure pxOrientation(newOrientation:TPrinterOrientation);
procedure pxBarCode(aRect:Trect;Text:string);
procedure pxBox(aRect:Trect;GrayLev:integer);
procedure pxTray(UseTray:integer);
procedure pxRaster(Left,Top,Width,Height,Density:integer;FileName:string);
end;
var lp:LPmain; { Contains printer descriptions and setups }
{ List of currently active printing windows or jobs in progress }
CurPrinting:array [1..MaxLpTitles] of string30;
procedure StartLinePrinter; { Call in the MainForm's FormCreate method }
procedure StopLinePrinter; { Call in the MainForm's FormClose method }
procedure DirectToPrinter(anEscSeq:string);
function cmX(Centimeters:double):integer; { Centimeters to ref. pixels }
function cmY(Centimeters:double):integer;
implementation
{$R *.DFM}
{ WNetGetConnection>0 no queue attached, 0-Queue name returned in RemoteName }
function WNetGetConnection(LocalDev,RemoteName:Pchar;
var RetSize:integer):integer;far;external 'USER';
function GetTitle(aStr:string):string;
var ii:integer;
begin
ii:=pos('::',upper(aStr));
result:=aStr;
if ii>0 then begin
result:=ltrim(trim(substr(aStr,ii+2,70)));
end;
ii:=pos(Dlm+Dlm,aStr);
if ii>10 then result:=substr(aStr,ii+2,70);
end;
procedure TPreview.FormCreate(Sender: TObject);
var ii:integer;
begin
width:=627;
height:=423;
left:=0;
top:=0;
centerhoriz(self);
Gen.AddWin('Preview',self);
CurPage:=1;
image1.width:=ScrnCanvasX;
image1.height:=ScrnCanvasY;
panel1.width:=image1.width;
for ii:=1 to MaxPages do wCommands[ii]:=nil;
Zoomable:=false;
FitToScreen:=false;
useLandScape:=false;
end;
procedure TPreview.FormClose(Sender: TObject; var Action: TCloseAction);
var bool:boolean;
ii:integer;
begin
bool:=true;
if pin('FORMAT',upper(caption)) then begin
bool:=YesNoBox('Close Preview Window During Formatting?');
end;
if bool then begin
for ii:=1 to wPageTot do begin
if wCommands[ii]<>nil then wCommands[ii].free;
end;
if Zoomable then begin
Gen.InBluePrint:=false;
Gen.FullBP.free; { free memory }
Gen.FullBP:=TBitMap.Create;
Gen.TinyBP.free; { free memory }
Gen.TinyBP:=TBitMap.Create;
end;
Gen.ReleaseWin(self);
action:=caFree;
end;
end;
procedure Lpr.Wout(xpos,ypos:integer;aStr:string);
var ii,jj,orgx:integer;
tt:string[20];
begin
{ xpos, ypos should be in canvas pixels }
jj:=length(astr);
if jj>0 then begin
with aCanvas do begin
brush.style:=bsClear;
if FixedWidth then begin
if not RowColStyle then begin
if WindowDest then begin
ColWidth:=Fixed12Width;
if font.size=10 then ColWidth:=Fixed10width;
if font.size=8 then ColWidth:=Fixed8width;
end else begin
ColWidth:=Colwidth-1;
if font.size=10 then ColWidth:=Colwidth-1;
if font.size=8 then ColWidth:=Colwidth;
end;
end;
orgx:=xpos;
{ adjust text spacing so a full will fit within the canvas width }
for ii:=1 to jj do begin
tt:=copy(astr,ii,1);
xpos:=orgx+(ii-1)*ColWidth;
textout(xpos,ypos,tt);
{ Corporate Mono won't produce underlines, have to use Courier }
if (fsUnderline in font.style) and (font.name=lp.FontList[2]) then begin
font.name:=lp.FontList[1];
textout(xpos,ypos,'_');
font.name:=lp.FontList[2];
end;
end;
end else begin
textout(xpos,ypos,astr);
end;
end;
end;
end;
procedure TPreview.PrintBluePrint(FullBMP:string);
var tlp:TPrinter;
PrintBP:TBitmap;
tcanvas:trect;
ii,jj:integer;
tt:string;
begin
caption:='Print B/P';
windowstate:=wsMinimized;
tlp:=TPrinter.create;
tlp.orientation:=poLandScape;
tlp.printerindex:=lp.curdest-1;
tlp.begindoc;
PrintBP:=tbitmap.create;
PrintBP.loadfromfile(FullBMP);
tlp.fCanvas.copyrect(tlp.fCanvas.cliprect,PrintBP.canvas,
PrintBP.canvas.cliprect);
tlp.enddoc;
tlp.destroy;
PrintBp.free;
close;
end;
procedure Lpr.SetTextStyle(forText:boolean);
begin
if WantsPreview then begin
if forText<>RowColStyle then
AddCommand(' 5'+Dlm+iifs(forText,'TRUE','FALSE'));
end;
RowColStyle:=forText;
EndCommand;
end;
procedure Lpr.setGDIfont(NewFont:string);
var ii,jj,OrgFont:integer;
tstyle:tfontstyles;
begin
if not empty(NewFont) then begin
OrgFont:=CurFont;
with aCanvas do begin
tstyle:=font.style;
{ when changing font type, must use style '1:12b', where '1:' is style }
if pin(':',NewFont) then begin
jj:=pos(':',NewFont);
if CurFont=0 then CurFont:=2; { default font type }
if jj>1 then begin
ii:=procint(copy(NewFont,1,jj));
NewFont:=copy(NewFont,jj+1,35);
if (ii>0) and (ii<=MaxFonts) then begin
if not empty(lp.FontList[ii]) then CurFont:=ii
else begin
if ii<6 then CurFont:=1 else Curfont:=6;
end;
end;
end;
if orgfont>0 then begin
if CurFont<>orgfont then begin
font.name:=lp.FontList[CurFont];
end;
end else font.name:=lp.FontList[CurFont];
end;
FixedWidth:=(CurFont<6);
if not WindowDest then begin
if upin('Generic',lp.LptPrinters[CurDest].PrName) then begin
{ cannot condense text, must layout to fit page as is }
CurFont:=1; { Courier }
font.name:=lp.FontList[CurFont];
FixedWidth:=false; { just print as is in wOut() }
end;
end;
{ if change size, must also reset style }
if procint(NewFont)>0 then begin
font.size:=procint(NewFont);
font.color:=clBlack;
tstyle:=[];
end;
if pin('B',upper(NewFont)) then begin
Include(tstyle,fsbold);
if CurFont=2 then begin
CurFont:=3;
font.name:=lp.FontList[CurFont];
end;
end;
if pin('U',upper(NewFont)) then Include(tstyle,fsUnderline);
if pin('I',upper(NewFont)) then Include(tstyle,fsItalic);
{ set back to normal }
if pin('N',upper(NewFont)) then begin
if CurFont=3 then begin { Corporate Mono Bold, back to normal }
CurFont:=2;
font.name:=lp.FontList[CurFont];
end;
tstyle:=[];
end;
font.style:=tstyle;
if WindowDest then RowHeight:=ScrnRowHeight div 60
else RowHeight:=CanvasHeight div 60;
if CurFont<6 then begin
if WindowDest then begin
Fixed12Width:=((CanvasWidth-25) div 80)+1;
Fixed10Width:=(CanvasWidth-25) div 104;
Fixed8Width:=(CanvasWidth-25) div 132;
end else begin
Fixed12Width:=CanvasWidth div 80;
Fixed10Width:=CanvasWidth div 104;
Fixed8Width:=CanvasWidth div 132;
end;
end;
ColWidth:=CanvasWidth div (80+1); { 12 pt }
if font.size=8 then ColWidth:=CanvasWidth div (132+1);
if font.size=10 then ColWidth:=CanvasWidth div (104+1);
end;
end;
end;
procedure Lpr.SetScaleXY;
var t1,t2:longint;
begin
CanvasWidth:=acanvas.cliprect.right;
CanvasHeight:=acanvas.cliprect.bottom;
RefAspectX:=RefPixPerInchX;
RefAspectY:=RefPixPerInchY;
PrnAspectX:=GetDeviceCaps(acanvas.handle,LOGPIXELSX);
PrnAspectY:=GetDeviceCaps(acanvas.handle,LOGPIXELSY);
{ for Screen is 96, squeeze a little tighter }
if WindowDest then begin
PrnAspectY:=PrnAspectY-4;
end;
{ ScaleXby and ScaleYby used to adjust reference pixels to
actual pixels }
t1:=PrnAspectX;
t2:=RefAspectX;
ScaleXby:=(t1*100) div t2;
t1:=PrnAspectY;
t2:=RefAspectY;
ScaleYby:=(t1*100) div t2;
end;
procedure Lpr.SetScaleXY70;
var t1,t2:longint;
begin
CanvasWidth:=acanvas.cliprect.right;
CanvasHeight:=acanvas.cliprect.bottom;
RefAspectX:=RefPixPerInchX;
RefAspectY:=RefPixPerInchY;
if WindowDest then begin
PrnAspectX:=ScrnPixPerInchX;
PrnAspectY:=ScrnPixPerInchX;
end else begin
PrnAspectX:=GetDeviceCaps(acanvas.handle,LOGPIXELSX);
PrnAspectY:=GetDeviceCaps(acanvas.handle,LOGPIXELSY);
end;
{ ScaleXby and ScaleYby used to adjust reference pixels to
actual pixels }
t1:=PrnAspectX;
t2:=RefAspectX;
ScaleXby:=(t1*100) div t2;
t1:=PrnAspectY;
t2:=RefAspectY;
ScaleYby:=(t1*100) div t2;
end;
function Lpr.ScaleX(RefX:integer):integer;
var longx:longint;
begin
longx:=RefX;
Result:=(longx*ScaleXby) div 100;
end;
function Lpr.ScaleY(RefY:integer):integer;
var longy:longint;
begin
longy:=RefY;
Result:=(longy*ScaleYby) div 100;
end;
constructor lpr.Create;
var ii:integer;
begin
inherited create;
Abort:=false;
Running:=false;
Preview:=nil;
AdjZeroX:=0.0;
AdjZeroY:=0.0;
FromPreview:=false;
WantsPreview:=false;
WindowDest:=false;
PrePrintedForm:=false;
for ii:=1 to MaxPages do Commands[ii]:=nil;
end;
function LPmain.CurrentPrinterInfo:string;
begin
result:='';
if lp.CurDest>0 then begin
with lp.LptPrinters[lp.curdest] do begin
result:=trim(Prname)+' ('+iifs(empty(Queue),PrPort,Queue)+')';
end;
end;
end;
procedure LPmain.GetPrinterType(aPrinterName:string;var pType:integer;
pWideCarriage:boolean);
var ii:integer;
tt,tt2:string;
begin
pType:=0;
pWideCarriage:=false;
with lp do begin
if AvailCnt>0 then begin
tt:=upper(aPrinterName);
for ii:=1 to AvailCnt do begin
tt2:=upper(AvailName[ii]);
if tt=tt2 then begin
pType:=AvailType[ii];
pWideCarriage:=AvailWide[ii];
break;
end;
end;
end;
end;
end;
function LPmain.GetQueueNum(ForQueue:string):Integer;
var ii:integer;
tt,tt2:string;
begin
result:=0;
with lp do begin
if QueueCnt>0 then begin
tt:=upper(ForQueue);
for ii:=1 to QueueCnt do begin
tt2:=upper(QueueName[ii]);
if tt=tt2 then begin
result:=ii;
break;
end;
end;
end;
end;
end;
procedure Lpr.SetZeroXY(aPrType:integer);
begin
{ Adjust origin for each printer for PrePrintedForm's }
AdjZeroX:=0.0;
AdjZeroY:=0.0;
if PrePrintedForm then begin
case aPrType of
5,6,7,8,13:begin { LaserJet's }
AdjZeroX:=-0.7;
AdjZeroY:=-0.95;
end;
2,3,4,12:begin { Canon BJ-200's }
AdjZeroX:=-0.8;
AdjZeroY:=-0.65;
end;
10,11:begin { HP DeskJet's }
AdjZeroX:=0.0;
AdjZeroY:=0.0;
end;
end;
end;
end;
procedure LPmain.LoadPrinters(FromFile:string);
var tt,tt2,q1,q2,q3:string;
tparscnt,ii,jj,kk:integer;
plist:tstringlist;
tp1,tp2:pchar;
tpars:array [1..MaxPars] of string135;
pr:TPrinter;
begin
pr:=TPrinter.create;
plist:=tstringlist.create;
plist.LoadFromFile(FromFile);
{ setup printer and queue types first }
AvailCnt:=0;
QueueCnt:=0;
for ii:=1 to MaxPrns do begin
AvailType[ii]:=0;
AvailName[ii]:='';
AvailWide[ii]:=false;
QueueName[ii]:='';
QueueTitle[ii]:='';
{ -1 so it will ignore unknown printers which have PrType=0 }
for jj:=1 to MaxQTypes do QueueType[ii][jj]:=-1;
with LptPrinters[ii] do begin
PrName:='';
PrPort:='';
PrType:=0;
CanSelect:=True;
PrWide:=False;
Queue:='';
end;
end;
for ii:=0 to plist.count-1 do begin
if pos('pp:',plist[ii])=1 then begin
split(plist[ii],':',tpars,tparscnt);
pp(AvailCnt);
AvailType[AvailCnt]:=procint(tpars[2]);
AvailName[AvailCnt]:=trim(tpars[3]);
AvailWide[AvailCnt]:=pin('WIDE',upper(plist[ii]));
{ always make the generice printer wide carriage }
if pin('GENERIC',upper(tpars[3])) then AvailWide[AvailCnt]:=true;
end;
if pos('qq:',plist[ii])=1 then begin
split(plist[ii],':',tpars,tparscnt);
pp(QueueCnt);
QueueName[QueueCnt]:=upper(trim(tpars[2]));
QueueTitle[QueueCnt]:=trim(tpars[3]);
split(tpars[4],',',tpars,tparscnt);
if tparscnt>MaxQTypes then begin
OKBox('Too Many Printers Defined For Queue '+QueueName[QueueCnt]);
tparscnt:=MaxQtypes;
end;
for jj:=1 to tparscnt do
QueueType[QueueCnt][jj]:=procint(tpars[jj]);
end;
end;
PrnCnt:=0;
{ findout which Queues are attached to the 3 lpt ports }
q1:='';
q2:='';
q3:='';
tp1:=stralloc(60);
tp2:=stralloc(60);
strpcopy(tp1,'LPT1');
strpcopy(tp2,'');
kk:=58; { set tp2 buffer size }
jj:=WNetGetConnection(tp1,tp2,kk);
if jj=0 then q1:=upper(strpas(tp2));
strpcopy(tp1,'LPT2');
strpcopy(tp2,'');
jj:=WNetGetConnection(tp1,tp2,kk);
if jj=0 then q2:=upper(strpas(tp2));
strpcopy(tp1,'LPT3');
strpcopy(tp2,'');
jj:=WNetGetConnection(tp1,tp2,kk);
if jj=0 then q3:=upper(strpas(tp2));
if pr.printers.count>0 then begin
for ii:=0 to pr.printers.count-1 do begin
split(pr.printers[ii],' on ',tpars,tparscnt);
{ skip printer server printers and Publisher Rendering System PUB }
if PrnCnt<MaxPrns then begin
pp(PrnCnt);
with LptPrinters[PrnCnt] do begin
PrName:=trim(tpars[1]);
tt2:=PrName;
jj:=pos('(',tt2);
if jj>0 then tt2:=trim(copy(tt2,1,jj-1));
GetPrinterType(tt2,PrType,PrWide);
PrPort:=upper(tpars[2]);
CanSelect:=True;
{ Ignore Print Server Printers, and MSPub Rendering Entry PUB: }
{ i.e. Jeff's Shared LaserJeft }
if upin('SHARED',tpars[1]) or upin('PUB',tpars[2]) then begin
CanSelect:=false;
end;
if (PrType=0) and (procint(PrPort)>0) and (CanSelect) then
Okbox('Need To Add '+Prname+' To '+PrnInitFile);
Queue:='';
if procint(PrPort)=1 then Queue:=q1;
if procint(PrPort)=2 then Queue:=q2;
if procint(PrPort)=3 then Queue:=q3;
jj:=GetQueueNum(Queue);
{ Check Queue printer type matches Windows setup }
if jj>0 then begin
for kk:=1 to MaxQTypes do begin
Queue:='';
if (PrType>0) and (PrType=QueueType[jj][kk]) then begin
Queue:=upper(QueueName[jj]);
break;
end;
end;
end else Queue:='';
end;
end;
end;
end;
{ final result of LastHardCopy destination saved by StopLinePrinter }
WantsPreview:=true;
CurDest:=pr.printerindex+1;
strdispose(tp1);
strdispose(tp2);
pr.free;
plist.free;
end;
procedure Lpr.Write(astr:string);
begin
p(Line,Pcol,astr);
end;
procedure Lpr.WriteLn(astr:string);
begin
p(line,pCol,astr);
Col:=0;
pp(line);
end;
procedure Lpr.P(atrow,atcol:integer;astr:string);
var OverPGlen:boolean;
begin
if Abort then Exit;
if WantsPreview then AddCommand(' 1'+Dlm+
inttostr(atrow)+Dlm+inttostr(atcol)+Dlm+astr);
OverPGlen:=false;
if atrow<Row then begin
Eject;
pp(page);
end;
if atrow>(PgLen+2) then begin
Eject;
OverPGlen:=true;
pp(page);
end;
Row:=atRow;
Col:=atcol;
if length(astr)>0 then begin
if not WantsPreview then begin
ColWidth:=iifi(Condensed,Fixed8Width,Fixed12Width);
wout(col*ColWidth,row*RowHeight,astr);
end;
Col:=Col+length(astr);
end;
if OverPGlen then begin { must not reset row and col till after print }
row:=0;
col:=0;
line:=-1;
end;
EndCommand;
end;
procedure Lpr.SetDestination;
{ Set printer options using LPmain info.
Should be called before StartDoc(), but only once, when
the choice to print has been made, not inside a loop of any kind
because the printer destination might be changed by some other event }
begin
NumOfCopies:=1;
CurDest:=lp.CurDest;
WantsPreview:=lp.WantsPreview;
WindowDest:=WantsPreview;
RpWide:=Lp.LptPrinters[curdest].PrWide;
end;
procedure Lpr.StartDoc2(ToPreview,Over80Wide:boolean;
aBriefTitle:string);
begin
FromPreview:=ToPreview;
StartDoc(Over80Wide,aBriefTitle);
end;
procedure Lpr.StartDoc(Over80Wide:boolean;aBriefTitle:string);
var ii:integer;
Use70,paper8x11:boolean;
tt,tt2:string;
begin
ShortTitle:=aBriefTitle;
for ii:=1 to MaxLpTitles do begin
if empty(CurPrinting[ii]) then begin
CurPrinting[ii]:=ShortTitle;
break;
end;
end;
Abort:=false;
Running:=true;
RpWide:=Over80Wide;
PgLen:=MaxPageLen;
NumOfCopies:=1;
{ page starts at 0,0 }
Row:=0;
Col:=0;
Page:=1;
Line:=0;
RowHeight:=1;
ColWidth:=1;
Use70:=false;
FromLoadToPrint:=false;
Fixed12Width:=0;
Fixed8Width:=0;
CurFont:=0;
ViewPageTot:=1;
Commands[ViewPageTot]:=tstringlist.create;
pr:=TPrinter.create;
InsideCommand:=false;
if CurDest>0 then pr.printerindex:=CurDest-1;
ShortTitle:=GetTitle(aBrieftitle);
ii:=pos('::',aBriefTitle);
{ wants accurate reference to units screen measurements }
Use70:=pin('70::',copy(aBriefTitle,1,ii));
if not FromPreview then begin
preview:=tpreview.create(application);
preview.caption:='Formatting '+ShortTitle;
preview.ViewPageTot:=1;
preview.panel1.width:=preview.image1.width;
Commands[ViewPageTot].insert(0,' 1'+Dlm+' 0'+Dlm+
iifs(RpWide,'for14x11','for8x11')+Dlm+Dlm+aBriefTitle);
end;
if WantsPreview then begin
WindowDest:=true;
SetZeroXY(0);
aCanvas:=Preview.image1.Canvas;
end else begin
if FromPreview then begin
if not WindowDest then begin
{if useLandScape then pr.Orientation:=poLandScape;}
SetZeroXY(lp.LptPrinters[lp.CurDest].PrType);
pr.begindoc;
pr.fcanvas.brush.style:=bsSolid;
pr.fcanvas.brush.color:=clWhite;
pr.fcanvas.fillrect(pr.fcanvas.cliprect);
aCanvas:=pr.fcanvas;
end;
end else begin
WindowDest:=false;
preview.caption:='Formatting '+aBriefTitle;
{if useLandScape then pr.Orientation:=poLandScape;}
SetZeroXY(lp.LptPrinters[lp.CurDest].PrType);
pr.begindoc;
pr.fcanvas.brush.style:=bsSolid;
pr.fcanvas.brush.color:=clWhite;
pr.fcanvas.fillrect(pr.fcanvas.cliprect);
aCanvas:=pr.fcanvas;
end;
end;
with aCanvas do begin
if not WindowDest then begin
paper8x11:=not Lp.LptPrinters[CurDest].PrWide;
end else begin
paper8x11:=true;
end;
if Use70 and WindowDest then SetScaleXY70 else SetScaleXY;
SetTextStyle(true); { start in text style }
with font do begin
SetGDIFont('2:12');
Condensed:=false;
if WindowDest then SetGDIFont('2:10');
if RpWide And paper8x11 then begin
Condensed:=true;
SetGDIFont('2:8');
end;
end;
end;
end;
procedure Lpr.StopDoc;
var ii:integer;
begin
for ii:=1 to MaxLpTitles do begin
if ShortTitle=CurPrinting[ii] then begin
CurPrinting[ii]:='';
break;
end;
end;
if not WindowDest then begin
preview.caption:='Printing '+ShortTitle;
if FromLoadToPrint then begin
{ special case when commands loaded from file }
pr.Abort; { close current printer device, handled by PlayBackPage }
preview.wCurDest:=CurDest;
preview.wPageTot:=ViewPageTot;
for ii:=1 to ViewPageTot do begin
preview.wCommands[ii]:=tstringlist.create;
preview.wCommands[ii].assign(Commands[ii]);
Commands[ii].free;
end;
{ keep track of StartDoc() settings }
preview.wRpWide:=RpWide;
preview.wShortTitle:=ShortTitle;
preview.playbackPage(false,0);
end else pr.EndDoc;
preview.close;
end;
pr.free;
Running:=false;
if WantsPreview then begin
preview.wCurDest:=CurDest;
preview.wPageTot:=ViewPageTot;
for ii:=1 to ViewPageTot do begin
preview.wCommands[ii]:=tstringlist.create;
preview.wCommands[ii].assign(Commands[ii]);
Commands[ii].free;
end;
{ keep track of StartDoc() settings }
preview.wRpWide:=RpWide;
preview.wShortTitle:=ShortTitle;
preview.CurPage:=1;
preview.PlayBackPage(true,1);
preview.setbuttons;
end;
end;
procedure Lpr.SetRowCol(toRow,toCol:integer);
begin
if Abort then Exit;
if WantsPreview then AddCommand(' 2'+Dlm+inttostr(torow)+Dlm+
inttostr(tocol));
Col:=toCol;
Row:=toRow;
EndCommand;
end;
procedure Lpr.CrLf;
begin
if Abort then Exit;
if WantsPreview then AddCommand(' 3');
pp(Row);
Col:=0;
EndCommand;
end;
procedure Lpr.Eject;
begin
if Abort then Exit;
if not WindowDest then pr.newpage
else begin
if ViewPageTot<MaxPages then begin
pp(ViewPageTot);
Commands[ViewPageTot]:=tstringlist.create;
end;
end;
Row:=0;
Line:=0;
Col:=0;
end;
function Lpr.pRow:integer;
begin
Result:=Row;
end;
function Lpr.pCol:integer;
begin
Result:=Col;
end;
function Lpr.SpecChars(istr:string):string;
var ii,tcnt:integer;
tst:string[10]; { special chars ~ ` ^ }
tt:string[3];
tarr:array [1..30] of string135;
begin
ii:=pos('+/-',istr);
if ii>0 then begin
tcnt:=0;
split(istr,'+/-',tarr,tcnt);
istr:=unsplit(tarr,'~',tcnt);
end;
for ii:=1 to length(istr) do begin
tst:=Copy(istr,ii,1);
if tst='`' then begin { degree }
istr[ii]:=chr(176);
End Else
Begin
if tst='~' then begin { +/- symbol }
istr[ii]:=chr(177);
End Else
Begin
if tst='^' then begin { Greek theta character }
istr[ii]:=chr(216);
End Else
Begin
if tst='_' then begin { replace underscores with spaces }
istr[ii]:=' ';
End;
End;
End;
End;
End;
Result:=istr;
end;
procedure Lpr.pxTray(usetray:integer);
var p1,r1:integer;
prt:string[20];
begin
if Abort then Exit;
if WantsPreview then AddCommand('28'+Dlm+inttostr(usetray))
else begin
{ not written yet }
end;
EndCommand;
end;
function cmX(Centimeters:double):integer; { centimeters to ref. pixels }
var ii:integer;
begin
ii:=procint(strd((Centimeters*RefAspectXdbl)/2.54,0));
result:=ii;
end;
function cmY(Centimeters:double):integer; { centimeters to ref. pixels }
var ii:integer;
begin
ii:=procint(strd((Centimeters*RefAspectYdbl)/2.54,0));
result:=ii;
end;
procedure Lpr.cmLine(left,top,width,height:double);
begin
pxLine(Rect(cmX(left+AdjZeroX),cmY(top+AdjZeroY),cmX(width),cmY(height)));
end;
procedure Lpr.cmBox(left,top,width,height:double;graylev:integer);
begin
pxBox(Rect(cmX(left+AdjZeroX),cmY(top+AdjZeroY),cmX(width),
cmY(height)),GrayLev);
end;
procedure Lpr.cmText(left,top:double;uzfont,thetext:string);
begin
pxText(Point(cmX(left+AdjZeroX),cmY(top+AdjZeroY)),uzFont,TheText);
end;
procedure Lpr.cmImage(IsColor:boolean;left,top:double;ScrnBMP,PrintBMP:string);
begin
pxImage(IsColor,Rect(cmX(left+AdjZeroX),cmY(top+AdjZeroY),0,0),
ScrnBMP,PrintBMP);
end;
procedure Lpr.cmBarCode(left,top,width,height:double;Text:string);
begin
pxBarCode(Rect(cmX(left+AdjZeroX),cmY(top+AdjZeroY),cmX(width),
cmY(height)),Text);
end;
procedure Lpr.pxRaster(Left,Top,Width,Height,Density:integer;FileName:string);
var tb,tb2:TBitmap;
map:tstringlist;
tt:string;
ii,jj,kk,zz,ll,ypos,xpos,tox,toy,shift:integer;
fromrect,torect:trect;
lcolor:longint;
begin
if Abort then Exit;
if WantsPreview then AddCommand('29'+Dlm+
ltrim(stri(left,5))+Dlm+ltrim(stri(top,5))+Dlm+
ltrim(stri(width,5))+Dlm+ltrim(stri(height,5))+Dlm+
ltrim(stri(density,5))+Dlm+FileName)
else begin
if not FileExists(FileName) then begin
OKbox('pxRaster, File Not Found: '+FileName);
exit;
end;
tb:=tbitmap.create;
tb2:=tbitmap.create;
tb.canvas.brush.style:=bsSolid;
tb.canvas.brush.color:=clWhite;
tb.canvas.fillrect(tb.canvas.cliprect);
map:=tstringlist.create;
map.loadfromfile(FileName);
tb.height:=300;
tb.width:=300;
tb2.height:=ScaleY(height);
tb2.width:=ScaleX(width);
shift:=1;
if density=75 then shift:=4;
if density=150 then shift:=2;
ii:=-1;
ypos:=0;
while ii<map.count-1 do begin
ii:=ii+1;
tt:=map[ii];
ll:=length(tt);
toy:=ypos+shift-1;
for zz:=ypos to toy do begin
with tb.canvas do begin
xpos:=0;
for jj:=1 to ll do begin
if tt[jj]<>'.' then begin
lcolor:=clBlack;
end else begin
lcolor:=clWhite;
end;
{ fill in gaps with last color }
tox:=xpos+shift-1;
for kk:=xpos to tox do begin
pixels[kk,zz]:=lcolor;
end;
xpos:=xpos+shift;
end;
end;
end;
ypos:=ypos+shift;
end;
fromrect:=rect(0,0,xpos,ypos);
tb2.canvas.CopyRect(tb2.canvas.cliprect,tb.canvas,fromrect);
aCanvas.Draw(ScaleX(left),ScaleY(top),tb2);
map.free;
tb.free;
tb2.free;
end;
EndCommand;
end;
procedure Lpr.pxLine(aRect:Trect);
begin
if Abort then Exit;
if WantsPreview then begin
AddCommand('21'+Dlm+
ltrim(stri(arect.left,5))+Dlm+ltrim(stri(arect.top,5))+Dlm+
ltrim(stri(arect.right,5))+Dlm+ltrim(stri(arect.bottom,5)));
end else begin
with aCanvas do begin
{ if right>bottom then horizontal line }
if arect.right>arect.bottom then pen.width:=arect.bottom
else pen.width:=arect.right;
if WindowDest then pen.width:=1;
brush.style:=bsClear;
moveto(ScaleX(arect.left),ScaleY(arect.top));
if arect.right>arect.bottom then { horizontal line }
lineto(ScaleX(arect.left+arect.right),ScaleY(arect.top))
else { vertical line }
lineto(ScaleX(arect.left),ScaleY(arect.top+arect.bottom));
end;
end;
EndCommand;
end;
procedure Lpr.pxBox(aRect:Trect;GrayLev:integer);
begin
if Abort then Exit;
if WantsPreview then AddCommand('22'+Dlm+
ltrim(stri(arect.left,5))+Dlm+ltrim(stri(arect.top,5))+Dlm+
ltrim(stri(arect.right,5))+Dlm+ltrim(stri(arect.bottom,5))+Dlm+
ltrim(stri(graylev,5)))
else begin
with aCanvas do begin
{ if i3>i4 then its a horizontal box }
brush.style:=bsSolid;
if graylev=0 then brush.color:=clBlack else
if graylev=1 then brush.color:=clWhite else begin
{ must use Yellow when printing light gray on paper }
if WindowDest then brush.color:=clAqua else brush.color:=clYellow;
end;
fillrect(rect(ScaleX(arect.left),ScaleY(arect.top),
ScaleX(arect.left+arect.right),ScaleY(arect.top+arect.bottom)));
end;
end;
EndCommand;
end;
procedure Lpr.pxOrientation(newOrientation:TPrinterOrientation);
begin
if Abort then Exit;
if WantsPreview then AddCommand('26'+Dlm+
iifs(newOrientation=poPortrait,'PORTRAIT','LANDSCAPE'))
else begin
if Not WindowDest then begin
pr.Orientation:=newOrientation;
pr.fcanvas.brush.style:=bsSolid;
pr.fcanvas.brush.color:=clWhite;
pr.fcanvas.fillrect(pr.fcanvas.cliprect);
aCanvas:=pr.fCanvas;
end;
end;
EndCommand;
end;
procedure DirectToPrinter(anEscSeq:string);
var ii:integer;
tt:pchar;
tlp:TPrinter;
begin
tlp:=TPrinter.create;
tlp.printerindex:=lp.CurDest-1;
tlp.begindoc;
tt:=stralloc(260);
strpcopy(tt,anEscSeq);
ii:=Escape(tlp.handle,PASSTHROUGH,length(anEscSeq),tt,nil);
tlp.enddoc;
StrDispose(tt);
tlp.free;
end;
procedure Lpr.pxImage(IsColor:boolean;aRect:Trect;ScrnBMP,PrintBMP:string);
var MustScale:boolean;
tt:string;
tim:tbitmap;
ii,jj:integer;
begin
if Abort then Exit;
if WantsPreview then AddCommand('25'+Dlm+iifs(IsColor,'TRUE','FALSE')+Dlm+
ltrim(stri(arect.left,5))+Dlm+ltrim(stri(arect.top,5))+Dlm+
ltrim(stri(arect.right,5))+Dlm+ltrim(stri(arect.bottom,5))+Dlm+
ScrnBMP+Dlm+PrintBMP)
else begin
tim:=tbitmap.create;
ii:=ScaleX(arect.left);
jj:=ScaleY(arect.top);
if WindowDest then begin
if not empty(ScrnBMP) then begin
tim.loadfromfile(ScrnBMP);
aCanvas.Draw(ii,jj,tim);
end;
end else begin
if not empty(PrintBMP) then begin
tim.loadfromfile(PrintBMP);
aCanvas.Draw(ii,jj,tim);
end;
end;
tim.free;
end;
EndCommand;
end;
procedure TPreview.ShowBigImage;
var tt,ll:integer;
halfx,halfy,adjx,adjy,tx,ty:double;
tr:trect;
begin
if FitToScreen then begin
image1.visible:=false;
image2.visible:=true;
SetButtons;
end else begin
image2.visible:=false;
if FirstTimeBig then MouseWait;
with image1 do begin
adjx:=Gen.FullBP.width/width;
adjy:=Gen.FullBP.height/height;
{ adjust BigX and BigY to correct relative position }
tx:=BigX;
ty:=BigY;
{ Scale X and Y from Image coords to Bitmap position }
tX:=tX*adjx;
tY:=tY*adjy;
halfx:=width div 2;
halfy:=height div 2;
{ set X dimensions }
ll:=procint(strd(tX-halfx,0));
if ll<0 then ll:=0;
if ll>(gen.fullBP.width-width) then ll:=gen.fullBP.width-width;
{ set Y dimensions }
tt:=procint(strd(tY-halfy,0));
if tt<0 then tt:=0;
if tt>(gen.fullBP.height-height) then tt:=gen.fullBP.height-height;
tr:=rect(ll,tt,ll+width-1,tt+height-1);
canvas.copyrect(canvas.cliprect,Gen.FullBP.canvas,tr);
if ll>0 then button1.enabled:=true
else button1.enabled:=false;
if tt>0 then button3.enabled:=true
else button3.enabled:=false;
if ll<(gen.fullBP.width-width) then button4.enabled:=true
else button4.enabled:=false;
if tt<(gen.fullBP.height-height) then button2.enabled:=true
else button2.enabled:=false;
visible:=true;
DoEvents;
if FirstTimeBig then MouseGo;
FirstTimeBig:=false;
end;
end;
end;
procedure lpr.SetCaption(toStr:string);
{ call before StopDoc }
begin
ShortTitle:=toStr;
end;
procedure TPreview.ShowBluePrint(aCaption,TinyBMP,FullBMP:string);
begin
if Gen.InBluePrint then begin
OKbox('Can Only Have One Blue Print Open At A Time');
close;
end else begin
windowstate:=wsNormal;
Gen.InBluePrint:=true;
Zoomable:=true;
image1.width:=613;
image1.height:=337;
image2.width:=613;
image2.height:=337;
panel1.width:=image1.width;
label1.caption:='Move>';
button3.caption:='&Up';
button2.caption:='&Down';
button1.caption:='&Left';
button4.caption:='&Right';
caption:=aCaption;
FitToScreen:=true;
Gen.TinyBP.loadfromfile(TinyBmp);
Gen.TinyBP.monochrome:=true;
image2.canvas.draw(0,0,Gen.TinyBP);
Gen.FullBP.loadfromfile(FullBmp);
FirstTimeBig:=true;
show;
ShowBigImage;
end;
end;
procedure Lpr.pxText(aPoint:TPoint;uzFont,TheText:string);
var curcol,atline:integer;
tt1,tt2,msg:string135;
i1,i2:longint;
begin
if Abort then Exit;
with aPoint do begin
if WantsPreview then AddCommand('24'+Dlm+
ltrim(stri(x,5))+Dlm+ltrim(stri(y,5))+Dlm+uzfont+Dlm+thetext)
else begin
with aCanvas do begin
setGDIfont(uzfont);
brush.style:=bsClear;
wout(ScaleX(x),ScaleY(y),thetext);
end;
end;
end;
EndCommand;
end;
procedure Lpr.pxBarCode(aRect:Trect;Text:string);
begin
if Abort then Exit;
if WantsPreview then AddCommand('27'+Dlm+
stri(arect.left,5)+Dlm+stri(arect.top,5)+Dlm+stri(arect.right,5)+Dlm+
stri(arect.bottom,5)+Dlm+text)
else begin
end;
EndCommand;
end;
procedure Lpr.TextFont(NewFont:string);
begin
if Abort then Exit;
SetTextStyle(true);
if WantsPreview then AddCommand(' 4'+Dlm+NewFont)
else SetGDIfont(NewFont);
EndCommand;
end;
function Lpr.Cancel:integer; { usually found in FormClose method }
var bool:boolean;
begin
Result:=0;
if Running then begin
bool:=YesNoBox('Cancel Printing');
if bool then begin
result:=2; { abort }
OKBox('After ''Wait'' Clears, You May Continue');
end else result:=1; { continue formatting }
end;
CancelState:=Result;
end;
procedure StartLinePrinter;
var ii:integer;
begin
Lp:=LPmain.Create;
for ii:=1 to MaxFonts do lp.FontList[ii]:='';
lp.FontList[1]:='Courier New';
{ from TypeCase 2001 fonts CD collection }
{lp.FontList[2]:='Corporate Mono';
lp.FontList[3]:='Corporate Mono Bold';}
{ variable width fonts are subscripts over 5 }
lp.FontList[6]:='Arial';
{ setup local printer type }
Lp.LoadPrinters(compath(PrnInitFile));
end;
procedure StopLinePrinter;
var ii:integer;
begin
Lp.free;
end;
procedure Lpr.AddCommand(CommandStr:string);
begin
if not InsideCommand then begin
InsideCommand:=true;
{ if using command below, "ff" in PlayBackPage S/B 3 }
{Commands[ViewPageTot].add(stri(ViewPageTot,2)+Dlm+
stri(Commands[ViewPageTot].count+1,3)+Dlm+CommandStr); }
{ if using command below, "ff" in PlayBackPage S/B 2 }
Commands[ViewPageTot].add(stri(ViewPageTot,2)+Dlm+CommandStr);
{ Why 2 ways? I have a frequent short report that only takes up a half
page, I store the results of the first in the top half, the next in
the bottom half. Then I use AddStrings() and Sort to merge the two
pages before finally printing. }
end;
end;
procedure Lpr.EndCommand;
begin
InsideCommand:=false;
end;
procedure TPreview.LoadCommands(fromFile:string);
var LoadList:Tstringlist;
ii,jj:integer;
begin
LoadList:=tstringlist.create;
LoadList.loadfromfile(fromFile);
wPageTot:=0;
for jj:=1 to MaxPages do begin
if wCommands[jj]<>nil then wCommands[jj].clear;
end;
for jj:=0 to LoadList.Count-1 do begin
ii:=strtoint(copy(LoadList[jj],1,2));
if ii<1 then ii:=1;
if wCommands[ii]=nil then wCommands[ii]:=tstringlist.create;
wCommands[ii].Add(LoadList[jj]);
if ii>wPageTot then wPageTot:=ii;
end;
LoadList.free;
end;
procedure TPreview.SaveCommands(toFile:string);
var SaveList:Tstringlist;
jj:integer;
begin
SaveList:=tstringlist.create;
for jj:=1 to wPageTot do SaveList.AddStrings(wCommands[jj]);
SaveList.savetofile(toFile);
SaveList.free;
end;
function TPreview.PlayBackPage(ToScreen:boolean;PageNum:integer):boolean;
var lpp:Lpr;
pcnt,opt,ii,jj,ff,start,finish:integer;
pstr:array [1..10] of string135;
tt,tt2:string;
begin
{ if Pagenum=0 then print all pages }
lpp:=Lpr.Create;
lpp.SetDestination;
with lpp do begin
CurDest:=wCurDest;
WantsPreview:=false;
WindowDest:=ToScreen;
start:=PageNum;
finish:=PageNum;
if PageNum=0 then begin
start:=1;
finish:=wPageTot;
end;
if ToScreen then begin
if empty(wShortTitle) then caption:='Preview'
else caption:=GetTitle(trim(wShortTitle));
windowstate:=wsNormal;
aCanvas:=image1.canvas;
StartDoc2(ToScreen,wRpWide,wShortTitle);
end else begin
if empty(wShortTitle) then lpp.preview.caption:='Printing'
else lpp.preview.caption:='Printing '+trim(wShortTitle);
lpp.useLandScape:=self.useLandScape;
StartDoc(wRpWide,wShortTitle);
end;
{ debug line}
{if Gen.User='BRAD ' then SaveCommands(TempPath('commands.txt'));}
for ii:=start to finish do begin
{ find first entry }
if ToScreen then begin
image1.canvas.brush.style:=bsSolid;
image1.canvas.brush.color:=clWhite;
image1.canvas.fillrect(image1.canvas.cliprect);
image1.visible:=false;
label2.caption:='Pg '+ltrim(stri(start,3))+
' of '+ltrim(stri(wPageTot,3));
MouseWait;
end;
if wCommands[ii].count>0 then begin
for jj:=0 to wCommands[ii].count-1 do begin
doevents2;
split(wCommands[ii][jj],Dlm,pstr,pcnt);
ff:=2; { first field after page number and/or sequence no. }
opt:=procint(pstr[ff]);
case opt of
{ Row,Col style reports }
1:p(procint(pstr[ff+1]),procint(pstr[ff+2]),pstr[ff+3]);
2:SetRowCol(procint(pstr[ff+1]),procint(pstr[ff+2]));
3:CrLf;
4:TextFont(pstr[ff+1]);
{ Special Commands }
5:SetTextStyle(pin('TRUE',pstr[ff+1]));
10:DirectToPrinter(pstr[ff+1]);
{ Raster style reports, called by above }
21:pxLine(Rect(procint(pstr[ff+1]),procint(pstr[ff+2]),
procint(pstr[ff+3]),procint(pstr[ff+4])));
22:pxBox(Rect(procint(pstr[ff+1]),procint(pstr[ff+2]),
procint(pstr[ff+3]),procint(pstr[ff+4])),procint(pstr[ff+5]));
24:pxText(Point(procint(pstr[ff+1]),procint(pstr[ff+2])),pstr[ff+3],
pstr[ff+4]);
25:begin
pxImage(pin('TRUE',pstr[ff+1]),Rect(procint(pstr[ff+2]),
procint(pstr[ff+3]),procint(pstr[ff+4]),
procint(pstr[ff+5])),pstr[ff+6],pstr[ff+7]);
end;
26:begin
if pin('PORTRAIT',pstr[ff+1]) then
pxOrientation(poPortrait)
else
pxOrientation(poLandScape);
end;
27:pxBarCode(Rect(procint(pstr[ff+1]),procint(pstr[ff+2]),
procint(pstr[ff+3]),procint(pstr[ff+4])),pstr[ff+5]);
28:pxTray(procint(pstr[ff+1]));
29:pxRaster(procint(pstr[ff+1]),procint(pstr[ff+2]),
procint(pstr[ff+3]),procint(pstr[ff+4]),
procint(pstr[ff+5]),pstr[ff+6]);
end;
end;
end else OKbox('Page '+inttostr(ii)+' Is Blank');
{ last page Eject in StopDoc }
if ToScreen then begin
MouseGo;
image1.visible:=true;
end;
if not ToScreen and (ii<finish) then Eject;
end;
StopDoc;
end;
result:=(lpp.CancelState<>2); { not cancelled }
lpp.free;
end;
procedure TPreview.BitBtn6Click(Sender: TObject);
begin
PlayBackPage(false,0);
end;
procedure TPreview.BitBtn1Click(Sender: TObject);
begin
PlayBackPage(false,CurPage);
end;
procedure TPreview.Button3Click(Sender: TObject);
begin
if zoomable then begin
BigY:=BigY-ScrollPixels;
if BigY<0 then BigY:=0;
ShowBigImage;
end else begin
Curpage:=1;
PlayBackPage(true,1);
SetButtons;
end;
end;
procedure TPreview.Button4Click(Sender: TObject);
begin
if zoomable then begin
BigX:=BigX+ScrollPixels;
ShowBigImage;
end else begin
CurPage:=wPageTot;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
procedure TPreview.Button2Click(Sender: TObject);
begin
if zoomable then begin
BigY:=BigY+ScrollPixels;
ShowBigImage;
end else begin
if CurPage>1 then begin
CurPage:=CurPage-1;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
end;
procedure TPreview.Button1Click(Sender: TObject);
begin
if zoomable then begin
BigX:=BigX-ScrollPixels;
if BigX<0 then BigX:=0;
ShowBigImage;
end else begin
if CurPage<wPageTot then begin
CurPage:=CurPage+1;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
end;
procedure TPreview.Edit1KeyPress(Sender: TObject; var Key: Char);
var ii:integer;
begin
if getret(key) then begin
ii:=procint(edit1.text);
if (ii>0) and (ii<=wPageTot) then begin
CurPage:=ii;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
end;
procedure TPreview.SetButtons;
begin
if Zoomable then begin
button1.enabled:=not FitToScreen;
button2.enabled:=not FitToScreen;
button3.enabled:=not FitToScreen;
button4.enabled:=not FitToScreen;
{ set popupmenu choices }
Firstpg1.enabled:=false;
Previouspg1.enabled:=false;
bitbtn6.enabled:=false;
gotopg1.enabled:=false;
bitbtn1.enabled:=false;
printall1.enabled:=false;
printpg1.enabled:=false;
Nextpg1.enabled:=false;
Lastpg1.enabled:=false;
edit1.enabled:=false;
end else begin
if wPageTot=1 then begin
button1.enabled:=false;
button2.enabled:=false;
button3.enabled:=false;
button4.enabled:=false;
{ set popupmenu choices }
Firstpg1.enabled:=false;
Previouspg1.enabled:=false;
bitbtn6.enabled:=false;
gotopg1.enabled:=false;
printall1.enabled:=false;
Nextpg1.enabled:=false;
Lastpg1.enabled:=false;
edit1.enabled:=false;
end else begin
button1.enabled:=true;
button2.enabled:=true;
button3.enabled:=true;
button4.enabled:=true;
Firstpg1.enabled:=true;
Previouspg1.enabled:=true;
Nextpg1.enabled:=true;
Lastpg1.enabled:=true;
edit1.enabled:=true;
bitbtn6.enabled:=true;
gotopg1.enabled:=true;
printall1.enabled:=true;
if CurPage=1 then begin
button3.enabled:=false;
button2.enabled:=false;
Firstpg1.enabled:=false;
Previouspg1.enabled:=false;
end;
if CurPage=wPageTot then begin
button4.enabled:=false;
button1.enabled:=false;
Nextpg1.enabled:=false;
Lastpg1.enabled:=false;
end;
end;
end;
end;
procedure Lpr.ForceToScreen;
begin
{ override current print dest., force report to Report Preview }
WantsPreview:=true;
WindowDest:=true;
end;
procedure Lpr.ForceToPrinter;
begin
{ override current print dest., force report to a printer }
WantsPreview:=false;
WindowDest:=false;
end;
procedure TPreview.Close1Click(Sender: TObject);
begin
Close;
end;
procedure TPreview.FirstPg1Click(Sender: TObject);
begin
Curpage:=1;
PlayBackPage(true,1);
SetButtons;
end;
procedure TPreview.PreviousPg1Click(Sender: TObject);
begin
if CurPage>1 then begin
CurPage:=CurPage-1;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
procedure TPreview.NextPg1Click(Sender: TObject);
begin
if CurPage<wPageTot then begin
CurPage:=CurPage+1;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
procedure TPreview.LastPg1Click(Sender: TObject);
begin
CurPage:=wPageTot;
PlayBackPage(true,CurPage);
SetButtons;
end;
procedure TPreview.PrintAll1Click(Sender: TObject);
begin
PlayBackPage(false,0);
end;
procedure TPreview.PrintPg1Click(Sender: TObject);
begin
PlayBackPage(false,CurPage);
end;
procedure TPreview.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if zoomable then begin
FitToScreen:=not FitToScreen;
BigX:=x;
BigY:=Y;
ShowBigImage;
end;
end;
procedure TPreview.Image2MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if zoomable then begin
FitToScreen:=not FitToScreen;
BigX:=x;
BigY:=Y;
ShowBigImage;
end;
end;
procedure TPreview.GoToPg1Click(Sender: TObject);
var ii:integer;
begin
ii:=procint(InputBox('Go To','Page #',''));
if (ii>0) and (ii<=wPageTot) then begin
CurPage:=ii;
PlayBackPage(true,CurPage);
SetButtons;
end;
end;
procedure TPreview.PrintCommandFile(aLoadSpec:string);
var ii:integer;
tt,tt2:string;
begin
ii:=pos('::',upper(aLoadSpec));
if ii>0 then begin
tt:=ltrim(trim(substr(aLoadSpec,ii+2,70)));
wShortTitle:=aLoadSpec;
if not FileExists(tt) then begin
OkBox('Pre-Load File Not Found: '+tt);
close;
end else begin
LoadCommands(tt);
wCurDest:=lp.curdest;
wShortTitle:=wCommands[1][0];
wRpWide:=pin('for14x11',wShortTitle);
if lp.WantsPreview then begin
windowstate:=wsNormal;
PlayBackPage(true,1); { start with page 1 }
SetButtons;
end else begin
windowstate:=wsMinimized;
PlayBackPage(false,0);
close;
end;
end;
end;
end;
procedure TPreview.FormActivate(Sender: TObject);
begin
Label5.caption:=lp.CurrentPrinterInfo;
end;
end.